home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / PowerLisp 1.01 / examples / testsuite.lisp < prev   
Encoding:
Text File  |  1993-08-03  |  3.8 KB  |  127 lines  |  [TEXT/ROSA]
  1. ;
  2. ;        Test program fragments from Guy L. Steele Jr.'s 
  3. ;        "Common Lisp, the Language", second edition,
  4. ;        and from Franz Inc.'s "Common Lisp, the Reference".
  5. ;
  6.  
  7. (defun _assert (x val) 
  8.     (let ((ret (eval x)))
  9.         (if (not (equal ret val)) 
  10.             (progn
  11.                 (print "assertion failed: ")
  12.                 (write "expression = ")
  13.                 (print x)
  14.                 (write "expected value = ")
  15.                 (print val)
  16.                 (write "evaluation returned: ")
  17.                 (print ret)
  18.                 nil)
  19.             t)))
  20.  
  21. (defmacro assert (expr expected-value)
  22.     `(_assert (quote ,expr) ,expected-value))
  23.             
  24. ; from Steele, p. 116
  25. (progn
  26. (defun adder (x) (function (lambda (y) (+ x y))))
  27. (setq add3 (adder 3))
  28. (assert
  29.     (funcall add3 5) 8)
  30. )
  31.  
  32. (progn
  33. (defun two-funs (x)
  34.     (list (function (lambda () x))
  35.           (function (lambda (y) (setq x y)))))
  36. (setq funs (two-funs 6))
  37. (assert (funcall (car funs)) 6)
  38. (assert (funcall (cadr funs) 43) 43)
  39. (assert (funcall (car funs)) 43)
  40. )
  41.  
  42. ; from Steele, p. 104
  43.  
  44. ; test eq function
  45. (progn
  46. (assert (eq 'a 'b) nil)
  47. (assert (eq 'a 'a) t)
  48. (eq 3 3)        ; implementation dependent
  49. (assert (eq 3 3.0) nil)
  50. ;  not implemented ; (assert (eq #c(3 -4) #c(3 -4)) nil)
  51. ;  not implemented ; (assert (eq #c(3 -4.0) #c(3 -4)) nil)
  52. (assert (eq (cons 'a 'b) (cons 'a 'c)) nil)
  53. (assert (eq (cons 'a 'b) (cons 'a 'b)) nil)
  54. (eq '(a . b) '(a . b)) ; implementation dependent
  55. (assert (progn (setq x (cons 'a 'b)) (eq x x)) t)
  56. (assert (progn (setq x '(a . b)) (eq x x)) t)
  57. (eq #\A #\A)              ; implementation dependent
  58. (eq "Foo" "Foo")          ; implementation dependent
  59. (assert (eq "Foo" (copy-seq "Foo")) nil)
  60. (assert (eq "FOO" "foo") nil))
  61.  
  62. ; test eql function
  63. (progn
  64. (assert (eql 'a 'b) nil)
  65. (assert (eql 'a 'a) t)
  66. (assert (eql 3 3) t)
  67. (assert (eql 3 3.0) nil)
  68. (assert (eql 3.0 3.0) t)
  69. ;  not implemented ; (assert (eql #c(3 -4) #c(3 -4)) t)
  70. ;  not implemented ; (assert (eql #c(3 -4.0) #c(3 -4)) nil)
  71. (assert (eql (cons 'a 'b) (cons 'a 'c)) nil)
  72. (assert (eql (cons 'a 'b) (cons 'a 'b)) nil)
  73. (eql '(a . b) '(a . b)) ; implementation dependent
  74. (assert (progn (setq x (cons 'a 'b)) (eql x x)) t)
  75. (assert (progn (setq x '(a . b)) (eql x x)) t)
  76. (assert (eql #\A #\A) t)
  77. (eql "Foo" "Foo")          ; implementation dependent
  78. (assert (eql "Foo" (copy-seq "Foo")) nil)
  79. (assert (eql "FOO" "foo") nil))
  80.  
  81. ; test equal function
  82. (progn
  83. (assert (equal 'a 'b) nil)
  84. (assert (equal 'a 'a) t)
  85. (assert (equal 3 3) t)
  86. (assert (equal 3 3.0) nil)
  87. (assert (equal 3.0 3.0) t)
  88. ;  not implemented ; (assert (equal #c(3 -4) #c(3 -4)) t)
  89. ;  not implemented ; (assert (equal #c(3 -4.0) #c(3 -4)) nil)
  90. (assert (equal (cons 'a 'b) (cons 'a 'c)) nil)
  91. (assert (equal (cons 'a 'b) (cons 'a 'b)) t)
  92. (assert (equal '(a . b) '(a . b)) t)
  93. (assert (progn (setq x (cons 'a 'b)) (equal x x)) t)
  94. (assert (progn (setq x '(a . b)) (equal x x)) t)
  95. (assert (equal #\A #\A) t)
  96. (assert (equal "Foo" "Foo") t)
  97. (assert (equal "Foo" (copy-seq "Foo")) t)
  98. (assert (equal "FOO" "foo") nil))
  99.  
  100. ; test equalp function
  101. (progn
  102. (assert (equalp 'a 'b) nil)
  103. (assert (equalp 'a 'a) t)
  104. (assert (equalp 3 3) t)
  105. (assert (equalp 3 3.0) t)
  106. (assert (equalp 3.0 3.0) t)
  107. ;  not implemented ; (assert (equalp #c(3 -4) #c(3 -4)) t)
  108. ;  not implemented ; (assert (equalp #c(3 -4.0) #c(3 -4)) t)
  109. (assert (equalp (cons 'a 'b) (cons 'a 'c)) nil)
  110. (assert (equalp (cons 'a 'b) (cons 'a 'b)) t)
  111. (assert (equalp '(a . b) '(a . b)) t)
  112. (assert (progn (setq x (cons 'a 'b)) (equalp x x)) t)
  113. (assert (progn (setq x '(a . b)) (equalp x x)) t)
  114. (assert (equalp #\A #\A) t)
  115. (assert (equalp "Foo" "Foo") t)
  116. (assert (equalp "Foo" (copy-seq "Foo")) t)
  117. (assert (equalp "FOO" "foo") t))
  118.  
  119. ;    From Steele p.216
  120. (setq _x_ '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6))
  121. (assert (equal (mapcar #'floor _x_) '(2 2 2 0 0 -1 -1 -3 -3 -3)) t)
  122. (assert (equal (mapcar #'ceiling _x_) '(3 3 3 1 1 0 0 -2 -2 -2)) t)
  123. (assert (equal (mapcar #'truncate _x_) '(2 2 2 0 0 0 0 -2 -2 -2)) t)
  124. (assert (equal (mapcar #'round _x_) '(3 2 2 1 0 0 -1 -2 -2 -3)) t)
  125.  
  126.  
  127.